(in-package :yadd)

;; Basic utils

(defmacro if-bind (var test &body then/else)
  "Binds value of test to symbol var. Evaluate `then' clause when
   value of `test' is not nil, else evaluate `else'."
  (assert (first then/else) (then/else) "IF-BIND missing THEN clause.")
  (destructuring-bind (then &optional else) then/else
    `(let ((,var ,test))
       (if ,var ,then ,else))))

(defmacro if-let (bindings &body then/else)
  "Binds variables to values like let* form and evaluates `then' clause
   when all values are non-nil, else evaluates `else' clause."
  (destructuring-bind (then &optional else) then/else
    (if bindings
        (destructuring-bind ((var form) &rest rest-bindings) bindings
          `(if-bind ,var ,form 
             (if-let ,rest-bindings ,@then/else)
             (progn ,else)))
        `(progn ,then))))

(defmacro when-let (bindings &body body)
  "Binds variables to values like let* form and evaluates body
   when all values are non-nil."
  (if bindings
      (destructuring-bind ((var form) &rest rest-bindings) bindings
        `(if-bind ,var ,form (when-let ,rest-bindings ,@body)))
      `(progn ,@body)))

(defmacro with-gensyms ((&rest names) &body body)
  `(let ,(loop for n in names collect `(,n (gensym)))
     ,@body))

(defun str (&rest args)
  "Returns the concatenation of string values of the args.
   With no or nil args, returns the empty string."
  (with-output-to-string (s)
    (dolist (arg args) (princ (or arg "") s))))

(defun not-null (x)
  (not (null x)))

(defun empty? (seq)
  "Returns true if x is empty sequence (list, string, etc.)"
  (= (length seq) 0))

(defun not-empty (seq)
  "Returns sequence when it is not empty."
  (unless (empty? seq) seq))

(defun consed (cons-obj)
  "Returns argument when it is consed object."
  (and (consp cons-obj) cons-obj))

(defun flat (list)
  "Expands all nested lists."
  (labels ((rec (x acc)
             (cond ((null x) acc)
                   ((atom x) (cons x acc))
                   (t (rec (car x) (rec (cdr x) acc))))))
    (rec list nil)))

(defun range (&key (start 1) end (step 1))
  "Returns a list of nums from start to end by step,
   where start defaults to 1 and step to 1."
  (loop for i from start to end by step collecting i))

;; (interleave & colls)
;; Returns a lazy seq of the first item in each coll, then the second etc.

(defun interpose (separator list)
  "Returns a list of the separated elements."
  (labels ((recur (list)
             (when (consed list)
               (cons separator (cons (first list) (recur (rest list)))))))
    (cons (first list) (recur (rest list)))))

;; (iterate f x)
;; Returns a lazy sequence of x, (f x), (f (f x)) etc.
;; f must be free of side-effects

;; (partition n coll)
;; (partition n step coll)
;; Returns a lazy sequence of lists of n items each, at offsets step apart.
;;  If step is not supplied, defaults to n, i.e. the partitions do not overlap.

;; (split-at n coll)
;; Returns a vector of [(take n coll) (drop n coll)]

;; (split-with pred coll)
;; Returns a vector of [(take-while pred coll) (drop-while pred coll)]

(defun take (n list)
  "Returns a lazy sequence of the first n items in coll,
   or all items if there are fewer than n."
  (when (plusp n) 
    (when-let ((l (consed list)))
      (cons (first l) (take (decf n) (rest l))))))

(defun drop (n list)
  "Returns a lazy sequence of all but the first n items in coll."
  (labels ((recur (n list)
             (let ((l (consed list)))
               (if (and (plusp n) l)
                   (recur (decf n) (rest l))
                   l))))
    (recur n list)))

;; (defn drop-last
;;   "Return a lazy sequence of all but the last n (default 1) items in coll"
;;   ([s] (drop-last 1 s))
;;   ([n s] (map (fn [x _] x) s (drop n s))))

;; (defn drop-while
;;   "Returns a lazy sequence of the items in coll starting from the first
;;   item for which (pred item) returns nil."
;;   [pred coll]
;;   (let [step (fn [pred coll]
;;                (let [s (seq coll)]
;;                  (if (and s (pred (first s)))
;;                    (recur pred (rest s))
;;                    s)))]
;;     (lazy-seq (step pred coll))))

(defun take-while (pred list)
  (when-let ((l (consed list)))
    (when (funcall pred (first l))
      (cons (first l) (take-while pred (rest l))))))

(defun group-by (f list &key test)
  ;; assoc item alist &key key test test-not => entry
  "Returns a associated list of the elements of list keyed by the result of
  f on each element. The value at each key will be a list of the
  corresponding elements, in the order they appeared in list."
  (labels ((recur (in out)
             (let* ((g (first (first in)))
                    (v (rest (first in)))
                    (gr-ex (if test
                               (assoc g out :test test)
                               (assoc g out)))
                    (v-ex (rest gr-ex)))
               (cond ((null in) out)
                     ((not gr-ex)
                      (recur (rest in) (adjoin (cons g v) out)))
                     (T (recur (rest in) (adjoin (cons g (if (listp v-ex)
                                                             (cons v v-ex)
                                                             (list v v-ex)))
                                                 (remove gr-ex out))))))))
    (recur (pairlis (mapcar f list) list) nil)))

(defun partition-by (f list) ;; STACK CRUSHES on big list
  "Applies f to each value in coll, splitting it each time f returns
   a new value.  Returns a lazy seq of lazy seqs."
  (when-let ((l (consed list)))
    (let* ((fst (first l))
           (fv (funcall f fst))
           (run (cons fst
                      (take-while
                       #'(lambda (x) (equal fv (funcall f x))) (rest l)))))
      (cons run (partition-by f (drop (length run) l))))))

(defun separate (pred list)
  "Split list into 2 lists: elements in 1st matches pred, 
   elements in 2nd matches complement pred."
  (list (remove-if pred list) (remove-if (complement pred) list)))

(defun indexed (list)
  "Returns an associated list of (index . item) pairs, where items come
  from 's' and indexes count up from zero.
  (indexed '(a b c d))  =>  ((0 a) (1 b) (2 c) (3 d))"
  (loop for index from 0 for item in list collecting (cons index item)))

(defun compose (&rest functions)
  "Takes a list of functions and returns a function that is the composition
  of those functions.  The returned fn takes a variable number of args,
  applies the rightmost of fns to the args, the next
  fn (right-to-left) to the result, etc."
  (labels ((recur (ret fs)
             (if fs (recur (funcall (first fs) ret) (rest fs)) ret)))
    (let ((fs (reverse functions)))
      (lambda (&rest args)
        (recur (apply (first fs) args) (rest fs))))))

(defun curry (f &optional (arg1 nil 1arg) (arg2 nil 2arg) (arg3 nil 3arg)
              &rest more)
  "Takes a function and fewer than the normal arguments, and
  returns a function that takes a variable number of additional args. When
  called, the returned function calls function with args + additional args."
  (cond (more (lambda (&rest args) (apply f arg1 arg2 arg3 (append more args))))
        (3arg (lambda (&rest args) (apply f arg1 arg2 arg3 args)))
        (2arg (lambda (&rest args) (apply f arg1 arg2 args)))
        (1arg (lambda (&rest args) (apply f arg1 args)))
        (t    (lambda (&rest args) (apply f args)))))

;; METAOBJECT utilities

(defun subclasses (class-name)
  (labels ((subclasses (class)
             (when-let ((direct (sb-mop:class-direct-subclasses class)))
               (cons direct (mapcar #'subclasses direct)))))
    
    (flat (subclasses (find-class class-name)))))

(defun finalize-subclasses-inheritance (class-name)
  (dolist (subclass (subclasses class-name))
    (sb-mop:finalize-inheritance subclass)))
  
;; OTHER utilities

(defun string->vector (string)
  (iter (for char in-string string) (collect (char-code char) result-type 'vector)))

;; (defun iconvert (from to string)
;;   (coerce (iter (for code in-vector
;;                      (iconv:iconv from to (string->vector string)))
;;                 (collect (code-char code)))
;;           'string))

(defmacro re (regex)
  `(create-scanner ,regex))

(defun read-lines (file)
  "Returns list of lines in file."
  (with-open-file (in file :direction :input)
    (loop for line = (read-line in nil nil) while line collect line)))

(defun transfer-bytes (&key from-stream to-stream)
  (when (and (streamp from-stream) (streamp to-stream))
    (iter (for byte in-stream from-stream using #'read-byte)
          (write-byte byte to-stream))))

(defun muproc-kill-all ()
  (mapcar (lambda (x) (muproc-kill x "MASS KILL!")) (muproc-all-processes)))

(defun logg (control-string &rest format-args)
  (apply (if (in-muproc-p)
             #'muproc-log-errorstream
             (curry #'format *error-output*))
         control-string format-args))

(defmacro uri-host (uri)
  `(bind-standard-uri-components ,uri %uri-host))

(defmacro uri-file (uri)
  `(bind-standard-uri-components ,uri %uri-file))

(defmacro uri-path (uri)
  `(bind-standard-uri-components ,uri %uri-path))

(defmacro uri-query (uri)
  `(bind-standard-uri-components ,uri %uri-query))

(defmacro uri-scheme (uri)
  `(bind-standard-uri-components ,uri %uri-scheme))

(defun header (uri)
  "Get header of HTTP request on URI."
  (when (not-empty uri)
    (nth-value 2 (http-request uri :method :head))))

(defmacro header-parameter (header parameter &optional subparameter)
;; (header-parameter head-reply :CONTENT-DISPOSITION :FILENAME)
;; (header-parameter head-reply :DATE)
  (with-gensyms (param subparam)
    `(let ((,param (rest (assoc ,parameter ,header))))
       (if ,subparameter
           (register-groups-bind (,subparam)
               ((str "(?i)" (symbol-name ,subparameter) "=" "(?-i)([^;]*)")
                ,param)
                ,subparam)
           ,param))))

(defun range-header (&key ((:start start) 0) ((:end end) nil end?))
  (cons "Range" (str "bytes=" start #\- (when end? end))))

(defun encode-uri (uri)
  ;; pchar         = unreserved / pct-encoded / sub-delims / ":" / "@"
  ;; unreserved  = ALPHA / DIGIT / "-" / "." / "_" / "~"
  ;; sub-delims  = "!" / "$" / "&" / "'" / "(" / ")" / "*" / "+" / "," / ";" / "="
  (let* ((scipped "/a-zA-Z0-9\\-\\.\\_\\~\\%\\!\\?\\$\\&\\'\\(\\)\\*\\+\\,\\;\\=\\:\\@")
         (scipped-other-re (create-scanner (str "([" scipped "])|([^" scipped "]+)"))))
    (with-output-to-string (out)
      (bind-standard-uri-components uri
        (progn (when %uri-head (princ %uri-head out))
               (do-register-groups (scipped other)
                   (scipped-other-re %uri-tail)
                 (princ (or scipped
                            (when other (kmrcl:encode-uri-string other))) out)))))))